home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
turboinc.arc
/
MAILSYS.INC
< prev
Wrap
Text File
|
1985-09-25
|
17KB
|
656 lines
const
numsects = 12;
maxlength = 24;
maxlenstr = '24';
type
messages = record
number: integer;
sender: integer;
recver: integer;
subject: name;
date: name;
private: boolean;
section: byte;
repto: integer;
reply: integer;
recved: boolean;
end;
sectname = array[1..numsects] of string[20];
messtext = array[1..maxlength] of line;
const
sect : sectname = ('1: General',
'2: Ohio Scientific',
'3: CP/M',
'4: Buy and Sell',
'5: 6502',
'6: Turbo Pascal',
'7: C',
'8: CompuServe',
'9: 6809',
'10: Kaypro',
'11: MS-DOS',
'12: TurboBBS code');
maxmess = 52; { <-- Maximum number of messages - this limit due to CP/M
maximum directory size on Kaypro.}
var
messagefile: file of messages;
count: integer;
messtable: array[1..maxmess] of messages;
preformat: boolean;
function namemess(number: integer): name;
var
filename: name;
begin
str((10000 + number):6, filename);
namemess := messdrive + 'MESS' + copy(filename, 3, 4) + '.TXT';
end;
procedure kill(x: integer);
var
victim: text;
begin
assign(victim, namemess(x));
erase(victim);
end;
function secure(tabloc: byte): boolean;
begin
with messtable[tabloc] do
secure := ((usernum <> sender)
and (usernum <> recver)
and (access < sysop))
or (usernum = 0);
end;
procedure listsections;
var
loopvar : integer;
temp : line;
begin
if cts then begin
clearsc;
lineout('Sections:' + cr + lf);
for loopvar := 1 to numsects do begin
lineout(sect[loopvar]);
end;
end;
end;
procedure status;
var
temp: line;
begin
if cts then begin
lineout(cr + lf + 'Caller: ' + caller);
str(access:1, temp);
lineout('Access level: ' + temp);
str(count:2, temp);
lineout('System has ' + temp + ' messages;');
str(nextmess:4, temp);
lineout('Next message is: ' + temp);
end;
end;
procedure initmess;
begin
if cts then lineout(cr + lf + 'Initializing message system...');
count := 0;
nextmess := 1;
assign(messagefile, 'MESSAGES.BBS');
{$I-} reset(messagefile) {$I+};
if IOresult = 0 then begin
while (count < maxmess) and not eof(messagefile) do begin
count := count + 1;
read(messagefile, messtable[count]);
end;
close(messagefile);
if count > 0 then nextmess := messtable[count].number + 1;
end;
unload;
messopen := true;
status;
end;
function findmessage(x: integer): byte;
var
loop: byte;
begin
loop := 0;
findmessage := 0;
if count > 0 then begin
repeat
loop := loop + 1;
until (loop >= count) or (messtable[loop].number >= x);
if messtable[loop].number = x
then findmessage := loop
else findmessage := 0;
end;
end;
function getname(usernum: integer): person;
var
tempid: sysid;
begin
seek(idfile, usernum-1);
read(idfile, tempid);
getname := tempid.user;
end;
procedure header(tabloc: byte);
var
temp: line;
begin
if cts then with messtable[tabloc] do begin
str(number:4, temp);
stringout(cr + lf);
if private then stringout('Private ');
stringout('Message #' + temp);
temp := getname(sender);
stringout(' is from: ' + temp);
if recver > 0 then temp := getname(recver) else temp := 'ALL';
if recved then temp := temp + ' (Rec''d)';
lineout(' to: ' + temp);
stringout('Subj: ' + subject);
if clockin then stringout(' Time: ' + date);
if sectsin then stringout(' Section ' + sect[section]);
lineout(space);
end;
end;
procedure destroy(tabloc: byte);
var
loop: byte;
begin
if tabloc > 0 then begin
kill(messtable[tabloc].number);
for loop := tabloc+1 to count do
messtable[loop-1] := messtable[loop];
count := count - 1;
lineout('Message deleted.');
end;
end;
procedure readfile(tabloc: byte);
begin
if cts then begin
outfile(namemess(messtable[tabloc].number));
lineout(space);
if (messtable[tabloc].recver = usernum) and (usernum > 0)
then messtable[tabloc].recved := true;
if cts and (tabloc > 1) and not secure(tabloc) then begin
if getcap('Delete (Y/N)? ') = 'Y' then destroy(tabloc);
end;
end;
end;
procedure readmess(number: integer);
var tabloc: byte;
begin
tabloc := findmessage(number);
if tabloc = 0 then lineout('Message not found.')
else if (secure(tabloc) and messtable[tabloc].private)
then lineout('Private message.')
else begin
header(tabloc);
readfile(tabloc);
end;
end;
procedure delmessage(x: integer);
var
tabloc: byte;
begin;
tabloc := findmessage(x);
if cts then begin
if tabloc > 0 then begin
if not secure(tabloc) then begin
header(tabloc);
if getcap('Are you sure (Y/N)? ') = 'Y' then destroy(tabloc);
end
else lineout('You can''t delete that message.');
end
else lineout('Message not found.');
end;
end;
function getid(prompt: line): integer;
var
temp: person;
begin
temp := allcaps(getinput(prompt, 28, echo));
if temp = '' then getid := 0 else getid := findid(temp);
end;
procedure deletex;
begin
if cts then delmessage(getint(nextmess - 1, 0, 'Delete: which number? '));
end;
procedure quickscan;
var
loop: byte;
first: integer;
begin
if cts then begin
first := getint(nextmess - 1, lastmess + 1, 'Start scan at which number (* for new)? ');
if first > 0 then begin
clearsc;
for loop := 1 to count do
if (messtable[loop].number >= first)
and not (secure(loop) and messtable[loop].private)
and cts and not cancelled
then header(loop);
end;
end;
end;
procedure readind;
var
messnum: integer;
tabloc : byte;
begin
repeat
messnum := getint(nextmess - 1, 0, 'Read which number (enter 0 to quit)? ');
if messnum > 0 then readmess(messnum);
until (messnum <= 0) or not cts;
end;
procedure messagesearch(first:byte; fromnum, tonum:integer; sectnum:byte);
var
loop: byte;
inch: char;
oldnum: integer;
matched: boolean;
begin
matched := false;
inch := null;
loop := first;
while cts and (loop <= count) and (inch <> 'Q') and (count <> 0) do begin
oldnum := messtable[loop].number;
if ((fromnum = 0) or (fromnum = messtable[loop].sender))
and ((tonum = 0) or (tonum = messtable[loop].recver))
and ((sectnum = 0) or (sectnum = messtable[loop].section))
and not (secure(loop) and messtable[loop].private)
then begin
matched := true;
cancelled := false;
header(loop);
inch := getcap('Read (Y/N/Quit)? ');
if inch = 'Y' then readfile(loop);
end;
if messtable[loop].number = oldnum then loop := loop + 1;
end;
if cts and not matched then lineout('No messages found.');
end;
function findfirst(startmess: integer): byte;
var loop : byte;
begin
loop := 0;
if count > 0 then repeat
loop := loop + 1;
until (messtable[loop].number >= startmess) or (loop = count);
findfirst := loop;
end;
function getfirst: byte;
var
startmess : integer;
begin
repeat
startmess := getint(nextmess - 1, lastmess + 1, 'Start at which message (? for stats, * for new)? ');
if startmess = -1 then status;
until (startmess <> -1) or not cts;
if startmess = 0 then getfirst := 0
else getfirst := findfirst(startmess);
end;
procedure readfrom;
var
fromnum: integer;
first: byte;
begin
if cts then begin
fromnum := getid('Enter name of sender: ');
if fromnum < 1
then stringout('Not a registered user name.')
else begin
first := getfirst;
if first > 0 then messagesearch(first, fromnum, 0, 0);
end;
end;
end;
procedure readto;
var
tonum: integer;
first: byte;
begin
if cts then begin
tonum := getid('Enter name of addressee: ');
if tonum < 1
then stringout('Not a registered user name.')
else begin
first := getfirst;
if first > 0 then messagesearch(first, 0, tonum, 0);
end;
end;
end;
procedure readsect;
var
first: byte;
inch: integer;
begin
if cts then repeat
if sectsin then
inch := getint(numsects, 0, 'Enter section number (0 for all, ? for list): ')
else inch := 1;
case inch of
-1 : listsections;
0..numsects: begin
first := getfirst;
if first > 0 then messagesearch(first, 0, 0, inch);
end;
end;
until (inch <> -1) or not cts;
end;
procedure receive;
var
uchar: char;
begin
if cts then begin
clearsc;
if not expert then outfile(readmenu);
repeat
uchar := getcap('Read mode: (A,I,F,T,S, or ? for menu)? ');
if uchar = '?' then outfile(readmenu);
until (uchar in ['A','I','F','T','S',cr]) or not cts;
if uchar = 'I' then readind;
if cts and (uchar <> 'I') then begin
case uchar of
'A': messagesearch(getfirst,0,0,0);
'F': readfrom;
'T': readto;
'S': readsect;
end;
end;
end;
end;
procedure closemess;
var
loop: byte;
begin
rewrite(messagefile);
for loop := 1 to count do
write(messagefile, messtable[loop]);
close(messagefile);
messopen := false;
end;
{make "enter" an overlay procedure and make filesys another one to save space}
procedure enter;
var
tabloc: byte;
messbuff: messtext;
linenum: byte;
inch: char;
procedure compose(var block: messtext; var linenum: byte);
var
temp: name;
begin
lineout(cr + lf + 'Enter message text: ' + maxlenstr + ' lines of 80 chars max.');
lineout('An empty line ends entry. "." at start of line forces new line.');
lineout(space);
if linenum < maxlength then repeat
linenum := linenum + 1;
str(linenum:2, temp);
stringout(temp + ': ');
block[linenum] := inputstring(echo);
until (linenum = maxlength) or (block[linenum] = '') or not cts;
if block[linenum] = '' then linenum := linenum - 1;
end;
procedure list(var block: messtext; first, last: byte);
var
loop: byte;
temp: name;
begin
if (first > 0) and (last > 0) and cts then begin
loop := first;
while (loop <= last) and (not cancelled) and cts do begin
str(loop:2, temp);
stringout(temp + ': ');
lineout(block[loop]);
loop := loop + 1;
end;
lineout(space);
end;
end;
procedure delline(var block: messtext; linenum: byte; var maxline: byte);
var temp: char;
loop: byte;
begin
list(block, linenum, linenum);
if cts and (linenum > 0) then begin
temp := getcap('Delete: are you sure (Y/N)? ');
if temp = 'Y' then begin
for loop := linenum+1 to maxline do block[loop-1] := block[loop];
block[maxline] := '';
maxline := pred(maxline);
lineout('Line deleted.');
end;
end;
end;
procedure edit(var block: messtext; linenum: byte);
var
oldstring: line;
newstring: line;
posn : integer;
begin
if (linenum > 0) and cts then begin
list(block, linenum, linenum);
oldstring := getinput('Enter string to replace: ', 80, echo);
newstring := getinput('Enter replacement: ', 80, echo);
posn := pos(oldstring, block[linenum]);
if posn <> 0 then begin
delete(block[linenum], posn, length(oldstring));
insert(newstring, block[linenum], posn);
list(block, linenum, linenum);
end
else lineout('Old string not found.');
lineout(space);
end;
end;
procedure replace(var block: messtext; linenum: byte);
begin
if (linenum > 0) and cts then begin
lineout('Old line:');
list(block, linenum, linenum);
lineout('Enter new line:');
stringout('? ');
block[linenum] := inputstring(echo);
end;
end;
function whichline(linenum: byte): byte;
var
temp: name;
x : integer;
begin
str(linenum:2, temp);
x := getint(linenum, 0, ' Which line? (1 - ' + temp + ')? ');
if (x <= 0) or not cts then whichline := 0 else whichline := x;
end;
procedure newheader(var entry: messages);
var
temp, tonum: integer;
begin
if cts then begin
entry.sender := usernum;
tonum := getid('Who to (RETURN or ENTER key for ALL)? ');
if tonum = 0 then lineout('Message to: ALL');
entry.recver := tonum;
entry.subject := getinput('Subject (14 characters max.)? ', 14, echo);
if clockin then begin
clock(month, date, hour, min, sec);
entry.date := time(month, date, hour, min, sec);
end;
if sectsin then repeat
temp := getint(numsects, 0, 'Which section (or "?" for list)? ');
if temp = -1 then listsections;
if temp in [1..numsects] then entry.section := temp;
until (temp in [1..numsects]) or not cts
else entry.section := 1;
if tonum > 0 then entry.private := getcap('Private message (Y/N)? ')='Y'
else entry.private := false;
entry.reply := 0;
entry.repto := 0;
entry.number := nextmess;
entry.recved := false;
end;
end;
procedure storemess(var block: messtext; tabloc, lastline: byte);
var
outfile: text;
linenum: byte;
begin
if cts then begin
lineout('Writing message to disk...');
assign(outfile, namemess(nextmess));
rewrite(outfile);
linenum := 1;
while linenum <= lastline do begin
if (copy(block[linenum],1,1) = '.') or preformat then begin
writeln(outfile);
if not preformat then
block[linenum] := copy(block[linenum], 2, length(block[linenum])-1);
end
else write(outfile, ' ');
write(outfile, block[linenum]);
linenum := linenum + 1;
end;
writeln(outfile);
close(outfile);
unload;
nextmess := nextmess + 1;
count := count + 1;
end;
end;
begin
preformat := false;
if cts then begin
clearsc;
if access < reg then lineout('You cannot enter messages yet: Use [A]pply command.')
else begin
tabloc := count + 1;
if tabloc > maxmess then lineout('No message space left.')
else begin
repeat
newheader(messtable[tabloc]);
header(tabloc);
inch := getcap('Is this OK (Y/N/Abort)? ');
until (inch <> 'N') or not cts;
unload;
if inch <> 'A' then begin
linenum := 0;
compose(messbuff, linenum);
if not expert then outfile(editmenu);
repeat
inch := getcap('Edit command: A,C,D,E,L,P,R,S or ? for menu? ');
case inch of
'C': compose(messbuff, linenum);
'D': delline(messbuff, whichline(linenum), linenum);
'E': edit(messbuff, whichline(linenum));
'L': list(messbuff, whichline(linenum), linenum);
'P': begin preformat := true; storemess(messbuff, tabloc, linenum); end;
'R': replace(messbuff, whichline(linenum));
'S': storemess(messbuff, tabloc, linenum);
'?': outfile(editmenu);
end;
until (inch = 'A')
or (inch = 'S')
or (inch = 'P')
or not cts;
end;
end; {2nd else}
end; {1st else}
end; {if cts}
end; {enter}